Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue49/Alfresco/AABinTre.pas

Pascal/Delphi Source File | 1999-07-25 | 25.8 KB | 860 lines

{*********************************************************}
{* AABinTre                                              *}
{* Copyright (c) Julian M Bucknall 1998-1999             *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco binary tree unit                  *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AABinTre;

interface

uses
  SysUtils;

{$IFOPT D+}
{$DEFINE InDebugMode}
{$ENDIF}

{$DEFINE UseNodeManager}

const
  PageNodeCount = 30;

type
  TaaCompareFunction = function (aItem1, aItem2 : pointer) : integer;

const
  aaLeft = true;
  aaRight= false;

type
  TaaBinaryTree = class;     {forward declaration}

  TaaTraversalMode = (       {different traversal modes..}
         tmPreOrder,         {..pre-order}
         tmInOrder,          {..in-order}
         tmPostOrder,        {..post-order}
         tmLevelOrder);      {..level-order}

  PaaBTNode = ^TaaBTNode;    {binary tree node}
  TaaBTNode = packed record
    btParent : PaaBTNode;
    btChild  : array [boolean] of PaaBTNode;
    btData   : pointer;
    btExtra  : longint;
  end;

  TaaDisposeItem = procedure (aItem : pointer);
    {-procedure prototype to dispose of an item}

  TaaProcessNode = function (aNode      : PaaBTNode;
                             aExtraData : pointer) : boolean;
    {-function prototype to process a node}

  TaaBinaryTree = class      {binary tree class}
    private
      FCount   : integer;
      FDispose : TaaDisposeItem;
      FHead    : PaaBTNode;
    protected
      function btLevelOrder(aAction : TaaProcessNode;
                            aExtraData : pointer) : PaaBTNode;
      function btNoRecInOrder(aAction : TaaProcessNode;
                              aExtraData : pointer) : PaaBTNode;
      function btNoRecPostOrder(aAction : TaaProcessNode;
                                aExtraData : pointer) : PaaBTNode;
      function btNoRecPreOrder(aAction : TaaProcessNode;
                               aExtraData : pointer) : PaaBTNode;
      function btRecInOrder(aNode   : PaaBTNode;
                            aAction : TaaProcessNode;
                            aExtraData : pointer) : PaaBTNode;
      function btRecPostOrder(aNode   : PaaBTNode;
                              aAction : TaaProcessNode;
                              aExtraData : pointer) : PaaBTNode;
      function btRecPreOrder(aNode   : PaaBTNode;
                             aAction : TaaProcessNode;
                             aExtraData : pointer) : PaaBTNode;
    public
      constructor Create(aDisposeItem : TaaDisposeItem);
      destructor Destroy; override;

      procedure Clear;
      procedure Delete(aNode : PaaBTNode);
      function InsertAt(aParentNode  : PaaBTNode;
                        aAsLeftChild : boolean;
                        aItem        : pointer) : PaaBTNode;
      function Root : PaaBTNode;
      function Traverse(aMode         : TaaTraversalMode;
                        aAction       : TaaProcessNode;
                        aExtraData    : pointer;
                        aUseRecursion : boolean) : PaaBTNode;

      property Count : integer read FCount;
  end;

  TaaBinarySearchTree = class      {binary search tree class}
    private
      FBinTree : TaaBinaryTree;
      FCompare : TaaCompareFunction;
      FCount   : integer;
    protected
      function bstFindItem(aItem    : pointer;
                       var aNode    : PaaBTNode;
                       var aUseLeft : boolean) : boolean;
    public
      constructor Create(aCompare : TaaCompareFunction;
                         aDispose : TaaDisposeItem);
      destructor Destroy; override;

      procedure Clear;
      procedure Delete(aItem : pointer);
      function Find(aKeyItem : pointer) : pointer;
      procedure Insert(aItem : pointer);
      function Traverse(aMode         : TaaTraversalMode;
                        aAction       : TaaProcessNode;
                        aExtraData    : pointer;
                        aUseRecursion : boolean) : pointer;

      property Count : integer read FCount;
      property BinaryTree : TaaBinaryTree read FBinTree;
  end;

type
  TaaDrawBinaryNode = procedure (aNode  : PaaBTNode;
                                 aStrip : integer;
                                 aColumn: integer;
                                 aParentStrip : integer;
                                 aParentColumn: integer;
                                 aExtraData   : pointer);

procedure DrawBinaryTree(aTree      : TObject;
                         aDrawNode  : TaaDrawBinaryNode;
                         aExtraData : pointer);

implementation

uses
  AALnkLst;

{===NodeManager for binary tree nodes================================}
type
  PnmPage = ^TnmPage;
  TnmPage = packed record
    nmpNext  : PnmPage;
    nmpNodes : array [0..pred(PageNodeCount)] of TaaBTNode;
  end;
{--------}
var
  nmFreeList : PaaBTNode;
  nmPageList : PnmPage;
{--------}
procedure nmFreeNode(aNode : PaaBTNode);
begin
  {$IFDEF UseNodeManager}
  {add the node to the top of the free list}
  aNode^.btParent := nmFreeList;
  nmFreeList := aNode;
  {$ELSE}
  Dispose(aNode);
  {$ENDIF}
end;
{--------}
procedure nmAllocPage;
var
  NewPage : PnmPage;
  i       : integer;
begin
  {get a new page}
  New(NewPage);
  {add it to the current list of pages}
  NewPage^.nmpNext := nmPageList;
  nmPageList := NewPage;
  {add all the nodes on the page to the free list}
  for i := 0 to pred(PageNodeCount) do
    nmFreeNode(@NewPage^.nmpNodes[i]);
end;
{--------}
function nmAllocNode : PaaBTNode;
begin
  {$IFDEF UseNodeManager}
  {if the free list is empty, allocate a new page of nodes}
  if (nmFreeList = nil) then
    nmAllocPage;
  {return the first node on the free list}
  Result := nmFreeList;
  nmFreeList := Result^.btParent;
  {$ELSE}
  New(Result);
  {$ENDIF}
  {$IFDEF InDebugMode}
  Result^.btParent := nil;
  Result^.btChild[aaLeft] := nil;
  Result^.btChild[aaRight] := nil;
  Result^.btData := nil;
  Result^.btExtra := 0;
  {$ENDIF}
end;
{====================================================================}


{===Helper routines==================================================}
function DisposeNode(aNode      : PaaBTNode;
                     aExtraData : pointer) : boolean; far;
var
  DisposeItem : TaaDisposeItem absolute aExtraData;
begin
  if (aExtraData <> nil) then
    DisposeItem(aNode^.btData);
  nmFreeNode(aNode);
  Result := true;
end;
{====================================================================}


{===TaaBinaryTree====================================================}
constructor TaaBinaryTree.Create(aDisposeItem : TaaDisposeItem);
begin
  inherited Create;
  FDispose := aDisposeItem;
  {allocate a head node, eventually the root node of the tree will be
   its left child}
  FHead := nmAllocNode;
  FHead^.btParent := nil;
  FHead^.btChild[aaLeft] := nil;
  FHead^.btChild[aaRight] := nil;
  FHead^.btData := nil;
  FHead^.btExtra := 0;
end;
{--------}
destructor TaaBinaryTree.Destroy;
begin
  Clear;
  nmFreeNode(FHead);
  inherited Destroy;
end;
{--------}
function TaaBinaryTree.btLevelOrder(aAction : TaaProcessNode;
                                    aExtraData : pointer) : PaaBTNode;
var
  Queue : TaaQueue;
  Node  : PaaBTNode;
begin
  {assume we won't get a node selected}
  Result := nil;
  {simple case first}
  if (FCount = 0) then
    Exit;
  {create the queue}
  Queue := TaaQueue.Create;
  try
    {enqueue the root}
    Queue.Enqueue(FHead^.btChild[aaLeft]);
    {continue until the queue is empty}
    while not Queue.IsEmpty do begin
      {get the node at the head of the queue}
      Node := Queue.Dequeue;
      {perform the action on it, if this returns false (ie, don't
       continue), return this node}
      if not aAction(Node, aExtraData) then begin
        Result := Node;
        Queue.Clear;
      end
      {otherwise, continue}
      else begin
        {enqueue the left child, if it's not nil}
        if (Node^.btChild[aaLeft] <> nil) then
          Queue.Enqueue(Node^.btChild[aaLeft]);
        {enqueue the right child, if it's not nil}
        if (Node^.btChild[aaRight] <> nil) then
          Queue.Enqueue(Node^.btChild[aaRight]);
      end;
    end;
  finally
    {destroy the queue}
    Queue.Free;
  end;
end;
{--------}
function TaaBinaryTree.btNoRecInOrder(aAction : TaaProcessNode;
                                      aExtraData : pointer) : PaaBTNode;
var
  Stack : TaaStack;
  Node  : PaaBTNode;
begin
  {assume we won't get a node selected}
  Result := nil;
  {simple case first}
  if (FCount = 0) then
    Exit;
  {create the stack}
  Stack := TaaStack.Create;
  try
    {push the root}
    Stack.Push(FHead^.btChild[aaLeft]);
    {continue until the stack is empty}
    while not Stack.IsEmpty do begin
      {get the node at the head of the queue}
      Node := Stack.Pop;
      {if it's nil, pop the next node, perform the action on it, if
       this returns false (ie, don't continue), return this node}
      if (Node = nil) then begin
        Node := Stack.Pop;
        if not aAction(Node, aExtraData) then begin
          Result := Node;
          Stack.Clear;
        end;
      end
      {otherwise, the children of the node have not been pushed yet}
      else begin
        {push the right child, if it's not nil}
        if (Node^.btChild[aaRight] <> nil) then
          Stack.Push(Node^.btChild[aaRight]);
        {push the node, followed by a nil pointer}
        Stack.Push(Node);
        Stack.Push(nil);
        {push the left child, if it's not nil}
        if (Node^.btChild[aaLeft] <> nil) then
          Stack.Push(Node^.btChild[aaLeft]);
      end;
    end;
  finally
    {destroy the stack}
    Stack.Free;
  end;
end;
{--------}
function TaaBinaryTree.btNoRecPostOrder(aAction : TaaProcessNode;
                                        aExtraData : pointer) : PaaBTNode;
var
  Stack : TaaStack;
  Node  : PaaBTNode;
begin
  {assume we won't get a node selected}
  Result := nil;
  {simple case first}
  if (FCount = 0) then
    Exit;
  {create the stack}
  Stack := TaaStack.Create;
  try
    {push the root}
    Stack.Push(FHead^.btChild[aaLeft]);
    {continue until the stack is empty}
    while not Stack.IsEmpty do begin
      {get the node at the head of the queue}
      Node := Stack.Pop;
      {if it's nil, pop the next node, perform the action on it, if
       this returns false (ie, don't continue), return this node}
      if (Node = nil) then begin
        Node := Stack.Pop;
        if not aAction(Node, aExtraData) then begin
          Result := Node;
          Stack.Clear;
        end;
      end
      {otherwise, the children of the node have not been pushed yet}
      else begin
        {push the node, followed by a nil pointer}
        Stack.Push(Node);
        Stack.Push(nil);
        {push the right child, if it's not nil}
        if (Node^.btChild[aaRight] <> nil) then
          Stack.Push(Node^.btChild[aaRight]);
        {push the left child, if it's not nil}
        if (Node^.btChild[aaLeft] <> nil) then
          Stack.Push(Node^.btChild[aaLeft]);
      end;
    end;
  finally
    {destroy the stack}
    Stack.Free;
  end;
end;
{--------}
function TaaBinaryTree.btNoRecPreOrder(aAction : TaaProcessNode;
                                       aExtraData : pointer) : PaaBTNode;
var
  Stack : TaaStack;
  Node  : PaaBTNode;
begin
  {assume we won't get a node selected}
  Result := nil;
  {simple case first}
  if (FCount = 0) then
    Exit;
  {create the stack}
  Stack := TaaStack.Create;
  try
    {push the root}
    Stack.Push(FHead^.btChild[aaLeft]);
    {continue until the stack is empty}
    while not Stack.IsEmpty do begin
      {get the node at the head of the queue}
      Node := Stack.Pop;
      {perform the action on it, if this returns false (ie, don't
       continue), return this node}
      if not aAction(Node, aExtraData) then begin
        Result := Node;
        Stack.Clear;
      end
      {otherwise, continue}
      else begin
        {push the right child, if it's not nil}
        if (Node^.btChild[aaRight] <> nil) then
          Stack.Push(Node^.btChild[aaRight]);
        {push the left child, if it's not nil}
        if (Node^.btChild[aaLeft] <> nil) then
          Stack.Push(Node^.btChild[aaLeft]);
      end;
    end;
  finally
    {destroy the stack}
    Stack.Free;
  end;
end;
{--------}
function TaaBinaryTree.btRecInOrder(aNode   : PaaBTNode;
                                    aAction : TaaProcessNode;
                                    aExtraData : pointer) : PaaBTNode;
begin
  Result := nil;
  if (aNode^.btChild[aaLeft] <> nil) then begin
    Result := btRecInOrder(aNode^.btChild[aaLeft], aAction, aExtraData);
    if (Result <> nil) then Exit;
  end;
  if not aAction(aNode, aExtraData) then begin
    Result := aNode;
    Exit;
  end;
  if (aNode^.btChild[aaRight] <> nil) then begin
    Result := btRecInOrder(aNode^.btChild[aaRight], aAction, aExtraData);
  end;
end;
{--------}
function TaaBinaryTree.btRecPostOrder(aNode   : PaaBTNode;
                                      aAction : TaaProcessNode;
                                      aExtraData : pointer) : PaaBTNode;
begin
  Result := nil;
  if (aNode^.btChild[aaLeft] <> nil) then begin
    Result := btRecPostOrder(aNode^.btChild[aaLeft], aAction, aExtraData);
    if (Result <> nil) then Exit;
  end;
  if (aNode^.btChild[aaRight] <> nil) then begin
    Result := btRecPostOrder(aNode^.btChild[aaRight], aAction, aExtraData);
    if (Result <> nil) then Exit;
  end;
  if not aAction(aNode, aExtraData) then begin
    Result := aNode;
  end;
end;
{--------}
function TaaBinaryTree.btRecPreOrder(aNode   : PaaBTNode;
                                     aAction : TaaProcessNode;
                                     aExtraData : pointer) : PaaBTNode;
begin
  Result := nil;
  if not aAction(aNode, aExtraData) then begin
    Result := aNode;
    Exit;
  end;
  if (aNode^.btChild[aaLeft] <> nil) then begin
    Result := btRecPreOrder(aNode^.btChild[aaLeft], aAction, aExtraData);
    if (Result <> nil) then Exit;
  end;
  if (aNode^.btChild[aaRight] <> nil) then begin
    Result := btRecPreOrder(aNode^.btChild[aaRight], aAction, aExtraData);
  end;
end;
{--------}
procedure TaaBinaryTree.Clear;
begin
  {to clear a binary tree, we perform a postorder traversal, with the
   action on each node being its disposal}
  btNoRecPostOrder(DisposeNode, @FDispose);
  FCount := 0;
  FHead^.btChild[aaLeft] := nil;
end;
{--------}
procedure TaaBinaryTree.Delete(aNode : PaaBTNode);
var
  HaveLeftChild : boolean;
  AmLeftChild   : boolean;
begin
  if (aNode = nil)then
    raise Exception.Create('TaaBinaryTree.Delete: node is nil');
  {find out whether we have a single child and which one it is; if we
   find that there are two children raise an exception}
  if (aNode.btChild[aaLeft] <> nil) then begin
    if (aNode.btChild[aaRight] <> nil) then
      raise Exception.Create(
          'TaaBinaryTree.Delete: cannot delete this node');
    HaveLeftChild := true;
  end
  else
    HaveLeftChild := false;
  {find out whether we're a left or right child of our parent}
  AmLeftChild := aNode^.btParent^.btChild[aaLeft] = aNode;
  {set the child link of our parent to our child link}
  aNode^.btParent^.btChild[AmLeftChild] :=
     aNode^.btChild[HaveLeftChild];
  {free the node}
  if Assigned(FDispose) then
    FDispose(aNode^.btData);
  nmFreeNode(aNode);
  dec(FCount);
end;
{--------}
function TaaBinaryTree.InsertAt(aParentNode  : PaaBTNode;
                                aAsLeftChild : boolean;
                                aItem        : pointer) : PaaBTNode;
begin
  {if the parent node is nil, assume this is inserting the root}
  if (aParentNode = nil) then begin
    aParentNode := FHead;
    aAsLeftChild := true;
  end;
  {check to see the child link isn't already set}
  if (aParentNode^.btChild[aAsLeftChild] <> nil) then
    raise Exception.Create('TaaBinaryTree.InsertAt: cannot insert here');
  {allocate a new node and insert as the required child of the parent}
  Result := nmAllocNode;
  Result^.btParent := aParentNode;
  Result^.btChild[aaLeft] := nil;
  Result^.btChild[aaRight] := nil;
  Result^.btData := aItem;
  Result^.btExtra := 0;
  aParentNode^.btChild[aAsLeftChild] := Result;
  inc(FCount);
end;
{--------}
function TaaBinaryTree.Root : PaaBTNode;
begin
  Result := FHead^.btChild[aaLeft];
end;
{--------}
function TaaBinaryTree.Traverse(aMode         : TaaTraversalMode;
                                aAction       : TaaProcessNode;
                                aExtraData    : pointer;
                                aUseRecursion : boolean) : PaaBTNode;
begin
  case aMode of
    tmPreOrder :
      if aUseRecursion then
        Result := btRecPreOrder(FHead^.btChild[aaLeft], aAction, aExtraData)
      else
        Result := btNoRecPreOrder(aAction, aExtraData);
    tmInOrder :
      if aUseRecursion then
        Result := btRecInOrder(FHead^.btChild[aaLeft], aAction, aExtraData)
      else
        Result := btNoRecInOrder(aAction, aExtraData);
    tmPostOrder :
      if aUseRecursion then
        Result := btRecPostOrder(FHead^.btChild[aaLeft], aAction, aExtraData)
      else
        Result := btNoRecPostOrder(aAction, aExtraData);
    tmLevelOrder :
      Result := btLevelOrder(aAction, aExtraData);
  else
    Result := nil;
  end;
end;
{====================================================================}


{===TaaBinarySearchTree==============================================}
constructor TaaBinarySearchTree.Create(aCompare : TaaCompareFunction;
                                       aDispose : TaaDisposeItem);
begin
  inherited Create;
  FCompare := aCompare;
  FBinTree := TaaBinaryTree.Create(aDispose);
end;
{--------}
destructor TaaBinarySearchTree.Destroy;
begin
  FBinTree.Free;
  inherited Destroy;
end;
{--------}
function TaaBinarySearchTree.bstFindItem(aItem    : pointer;
                                     var aNode    : PaaBTNode;
                                     var aUseLeft : boolean) : boolean;
var
  Walker : PaaBTNode;
  CmpResult : integer;
begin
  Result := false;
  if (FCount = 0) then begin
    aNode := nil;
    aUseLeft := true;
    Exit;
  end;
  Walker := FBinTree.Root;
  CmpResult := FCompare(aItem, Walker^.btData);
  while (CmpResult <> 0) do begin
    if (CmpResult < 0) then begin
      if (Walker^.btChild[aaLeft] = nil) then begin
        aNode := Walker;
        aUseLeft := true;
        Exit;
      end;
      Walker := Walker^.btChild[aaLeft];
    end
    else begin
      if (Walker^.btChild[aaRight] = nil) then begin
        aNode := Walker;
        aUseLeft := false;
        Exit;
      end;
      Walker := Walker^.btChild[aaRight];
    end;
    CmpResult := FCompare(aItem, Walker^.btData);
  end;
  Result := true;
  aNode := Walker;
end;
{--------}
procedure TaaBinarySearchTree.Clear;
begin
  FBinTree.Clear;
  FCount := 0;
end;
{--------}
procedure TaaBinarySearchTree.Delete(aItem : pointer);
var
  Walker  : PaaBTNode;
  Node    : PaaBTNode;
  UseLeft : boolean;
  Temp    : pointer;
begin
  {attempt to find the item; signal error if not found}
  if not bstFindItem(aItem, Node, UseLeft) then
    raise Exception.Create('TaaBinarySearchTree.Delete: item not found');
  {if the node has two children, find the largest node that is smaller
   than the one we want to delete, and swap over the items}
  if (Node^.btChild[aaLeft] <> nil) and
     (Node^.btChild[aaRight] <> nil) then begin
    Walker := Node^.btChild[aaLeft];
    while (Walker^.btChild[aaRight] <> nil) do
      Walker := Node^.btChild[aaRight];
    Temp := Walker^.btData;
    Walker^.btData := Node^.btData;
    Node^.btData := Temp;
    Node := Walker;
  end;
  {delete the node}
  FBinTree.Delete(Node);
  dec(FCount);
end;
{--------}
function TaaBinarySearchTree.Find(aKeyItem : pointer) : pointer;
var
  Node : PaaBTNode;
  UseLeft : boolean;
begin
  if bstFindItem(aKeyItem, Node, UseLeft) then
    Result := Node^.btData
  else
    Result := nil;
end;
{--------}
procedure TaaBinarySearchTree.Insert(aItem : pointer);
var
  Node : PaaBTNode;
  UseLeft : boolean;
begin
  {first attempt to find the item; if found, it's an error}
  if bstFindItem(aItem, Node, UseLeft) then
    raise Exception.Create(
       'TaaBinarySearchTree.Insert: duplicate keys not allowed');
  {this returns a node, so insert there}
  FBinTree.InsertAt(Node, UseLeft, aItem);
  inc(FCount);
end;
{--------}
function TaaBinarySearchTree.Traverse(aMode         : TaaTraversalMode;
                                      aAction       : TaaProcessNode;
                                      aExtraData    : pointer;
                                      aUseRecursion : boolean) : pointer;
var
  Node : PaaBTNode;
begin
  Node := FBinTree.Traverse(aMode, aAction, aExtraData, aUseRecursion);
  if (Node = nil) then
    Result := nil
  else
    Result := Node^.btData;
end;
{====================================================================}


{===Drawing a binary tree============================================}
type
  PNodePosn = ^TNodePosn;
  TNodePosn = packed record
    npStrip  : integer;
    npColumn : integer;
  end;
{--------}
procedure DrawBinaryTree(aTree      : TObject;
                         aDrawNode  : TaaDrawBinaryNode;
                         aExtraData : pointer);
  {------}
  function GenPosNode(aNode   : PaaBTNode;
                      aStrip  : integer;
                  var aColumn : integer) : PaaBTNode;
  var
    OurPosNode : PaaBTNode;
    OurPosition : PNodePosn;
  begin
    {allocate ourselves a node and a position}
    OurPosNode := nmAllocNode;
    FillChar(OurPosNode^, sizeof(OurPosNode^), 0);
    New(OurPosition);
    OurPosNode^.btData := OurPosition;

    {visit the left subtree}
    if (aNode^.btChild[aaLeft] <> nil) then begin
      OurPosNode^.btChild[aaLeft] :=
         GenPosNode(aNode^.btChild[aaLeft], succ(aStrip), aColumn);
      OurPosNode^.btChild[aaLeft]^.btParent := OurPosNode;
    end;

    {store our position, increment the column since we're there now}
    OurPosition^.npStrip := aStrip;
    OurPosition^.npColumn := aColumn;
    inc(aColumn);

    {visit the right subtree}
    if (aNode^.btChild[aaRight] <> nil) then begin
      OurPosNode^.btChild[aaRight] :=
        GenPosNode(aNode^.btChild[aaRight], succ(aStrip), aColumn);
      OurPosNode^.btChild[aaRight]^.btParent := OurPosNode;
    end;

    Result := OurPosNode;
  end;
  {------}
  procedure DestroyPosNode(aNode : PaaBTNode);
  begin
    {destroy the left subtree}
    if (aNode^.btChild[aaLeft] <> nil) then
      DestroyPosNode(aNode^.btChild[aaLeft]);
    {destroy the right subtree}
    if (aNode^.btChild[aaRight] <> nil) then
      DestroyPosNode(aNode^.btChild[aaRight]);
    {destroy this node}
    Dispose(PNodePosn(aNode^.btData));
    nmFreeNode(aNode);
  end;
  {------}
var
  BinTree : TaaBinaryTree;
  Strip, Column : integer;
  PStrip, PColumn : integer;
  PosRoot : PaaBTNode;
  Queue   : TaaQueue;
  Node    : PaaBTNode;
  PosNode : PaaBTNode;
begin
  {get a hold of the actual binary tree}
  if (aTree is TaaBinaryTree) then
    BinTree := TaaBinaryTree(aTree)
  else if (aTree is TaaBinarySearchTree) then
    BinTree := TaaBinarySearchTree(aTree).BinaryTree
  else
    Exit;

  {simple case first}
  if (BinTree.Count = 0) then
    Exit;

  {--first pass--}
  Strip := 0;
  Column := 0;
  PosRoot := GenPosNode(BinTree.Root, Strip, Column);

  {--second pass--}
  try
    {create the queue}
    Queue := TaaQueue.Create;
    try
      {enqueue the roots}
      Queue.Enqueue(BinTree.Root);
      Queue.Enqueue(PosRoot);
      {continue until the queue is empty}
      while not Queue.IsEmpty do begin
        {get the nodes at the head of the queue}
        Node := Queue.Dequeue;
        PosNode := Queue.Dequeue;
        {draw the node}
        if (PosNode = PosRoot) then begin
          PStrip := -1;
          PColumn := -1;
        end
        else with PNodePosn(PosNode^.btParent^.btData)^ do begin
          PStrip := npStrip;
          PColumn := npColumn;
        end;
        with PNodePosn(PosNode^.btData)^ do
          aDrawNode(Node, npStrip, npColumn,
                          PStrip, PColumn, aExtraData);
        {enqueue the left children, if the first is not nil}
        if (Node^.btChild[aaLeft] <> nil) then begin
          Queue.Enqueue(Node^.btChild[aaLeft]);
          Queue.Enqueue(PosNode^.btChild[aaLeft]);
        end;
        {enqueue the right children, if the first is not nil}
        if (Node^.btChild[aaRight] <> nil) then begin
          Queue.Enqueue(Node^.btChild[aaRight]);
          Queue.Enqueue(PosNode^.btChild[aaRight]);
        end;
      end;
    finally
      {destroy the queue}
      Queue.Free;
    end;
  finally
    {now destroy the position binary tree}
    DestroyPosNode(PosRoot);
  end;
end;
{====================================================================}


procedure FinalizeUnit; far;
var
  Temp : PnmPage;
begin
  {destroy all the single node pages}
  Temp := nmPageList;
  while (Temp <> nil) do begin
    nmPageList := Temp^.nmpNext;
    Dispose(Temp);
    Temp := nmPageList;
  end;
end;

initialization
  nmFreeList := nil;
  nmPageList := nil;
  {$IFDEF Windows}
  AddExitProc(FinalizeUnit);
  {$ENDIF}

{$IFDEF Win32}
finalization
  FinalizeUnit;
{$ENDIF}

end.